home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / rexx / imc / rexx-imc.5 / util.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-06-25  |  71.1 KB  |  1,828 lines
  1. /* The Utility functions of REXX/imc       (C) Ian Collier 1992 */
  2.  
  3. #include<memory.h>
  4. #include<sys/stat.h>
  5. #include<sys/file.h>
  6. #include<string.h>
  7. #include "functions.h"
  8. #include "globals.h"
  9. #include<malloc.h>
  10. #include<sys/param.h>
  11.  
  12. char *words[]= /* Keywords in order of their values */
  13.        {"SAY", "SAYN", "DO", "END", "IF", "ELSE", "SELECT", "WHEN",
  14.         "OPTIONS", "PARSE", "PUSH", "QUEUE", "EXIT", "RETURN", "CALL",
  15.         "SIGNAL", "ITERATE", "LEAVE", "INTERPRET", "TRACE", "OTHERWISE",
  16.         "NOP", "PROCEDURE", "ADDRESS", "NUMERIC", "DROP", "THEN", "PULL",
  17.         "ARG", "SOURCE", "VAR", "VERSION", "LINEIN", "VALUE", "WITH",
  18.         "UPPER", "TO", "BY", "FOR", "FOREVER", "WHILE", "UNTIL", "ON", "OFF",
  19.         "DIGITS", "FUZZ", "FORM", "EXPOSE", "HIDE", "NAME"};
  20.  
  21. typedef struct _varent {       /* a variable table entry */
  22.    int next;                   /* length of structure */
  23.    int less;                   /* position of left child within tree */
  24.    int grtr;                   /* position of right child within tree */
  25.    int namelen;                /* length of variable's name */
  26.    int valalloc;               /* length allocated to variable's value */
  27.    int vallen;                 /* actual length of variable's value */
  28. } varent;
  29.  
  30. char *message(rc)  /* Return errortext(rc) */
  31. int rc;
  32. {
  33.    extern char *sys_errlist[];
  34.    extern int sys_nerr;
  35.    if(rc>Eerrno&&rc<Eerrno+sys_nerr)return sys_errlist[rc-Eerrno];
  36.    if (rc== -3&&fname[0]!=0)perror(fname);
  37.    switch (rc){
  38.       case -3:        return "Error loading program";
  39.       case Einit:     return "Initialisation error";
  40.       case Ehalt:     return "Program interrupted";
  41.       case Emem:      return "Machine storage exhausted";
  42.       case Equote:    return "Unmatched \'/*\' or quote";
  43.       case Enowhen:   return "Expected WHEN/OTHERWISE";
  44.       case Ethen:     return "Unexpected THEN/ELSE";
  45.       case Ewhen:     return "Unexpected WHEN/OTHERWISE";
  46.       case Eend:      return "Unexpected or unmatched END";
  47.       case Echar:     return "Invalid character in program";
  48.       case Enoend:    return "Incomplete DO/SELECT/IF";
  49.       case Ehex:      return "Invalid binary or hexadecimal string";
  50.       case Elabel:    return "Label not found";
  51.       case Eprocedure:return "Unexpected PROCEDURE";
  52.       case Enothen:   return "Expected THEN";
  53.       case Enostring: return "String or symbol expected";
  54.       case Enosymbol: return "Symbol expected";
  55.       case Exend:     return "Invalid data on end of clause";
  56.       case Etrace:    return "Invalid TRACE request";
  57.       case Etrap:     return "Invalid subkeyword found";
  58.       case Erange:    return "Invalid whole number";
  59.       case Exdo:      return "Invalid DO syntax";
  60.       case Eleave:    return "Invalid LEAVE or ITERATE";
  61.       case Elong:     return "Symbol > 250 characters";
  62.       case Ename:     return "Name starts with number or \'.\'";
  63.       case Ebadexpr:  return "Invalid expression";
  64.       case Elpar:     return "Unmatched \'(\'";
  65.       case Ecomma:    return "Unexpected \',\' or \')\'";
  66.       case Eparse:    return "Invalid template";
  67.       case Eopstk:    return "Evaluation stack overflow (> 30 pending operations)";
  68.       case Ecall:     return "Incorrect call to routine";
  69.       case Enum:      return "Bad arithmetic conversion";
  70.       case Eoflow:    return "Arithmetic overflow or underflow";
  71.       case Eundef:    return "Routine not found";
  72.       case Enoresult: return "Function did not return data";
  73.       case Esys:      return "Failure in system service";
  74.       case Elost:     return "Implementation error";
  75.       case Eincalled: return "Error in called routine";
  76.       case Enovalue:  return "No-value error";
  77.       case Eexist:    return "Use of an un-implemented feature!";
  78.       case Esyntax:   return "Syntax error";
  79.       case Elabeldot: return "Label ends with \'.\'";
  80.       case Ercomm:    return "Unexpected \'*/\'";
  81.       case Emanyargs: return "Too many arguments (> 30)";
  82.       case Eerror:    return "ERROR condition occurred";
  83.       case Efailure:  return "FAILURE condition occurred";
  84.       case Eerrno:    return "Unknown error occurred during I/O";
  85.       case Ebounds:   return "File position was out of bounds";
  86.       case Eseek:     return "Reposition attempted on transient stream";
  87.       case Eaccess:   return "Write attempted on a read-only stream";
  88.       case Eeof+Eerrno:return"End of file";
  89.    }
  90.    return "";
  91. }
  92.  
  93. void rcset(rc,type,desc)/* set rc on return from system call */
  94. int rc;                 /* What to set rc to */
  95. int type;               /* What error to die with if the error is trapped */
  96. char *desc;             /* Description for condition(d) */
  97. {
  98.    char rcbuf[20];
  99.    int bit=type==Eerror?Ierror:type==Efailure?Ifailure:Inotready;
  100.    int catch=rc&&(sgstack[interplev].bits&(1<<bit));
  101.    int call=rc&&(sgstack[interplev].callon&(1<<bit));
  102.    if(interact>=0 && interact+1==interplev)
  103.       return;           /* no action for interactive commands */
  104.    if(rc && call==0 && catch==0 && type==Efailure)
  105.       type=Eerror,
  106.       bit=Ierror,
  107.       catch=sgstack[interplev].bits&(1<<bit),
  108.       call=sgstack[interplev].callon&(1<<bit);
  109.    if(type!=Enotready){ /* set rc after a command */
  110.       sprintf(rcbuf,"%d",rc);
  111.       varset("RC",2,rcbuf,strlen(rcbuf));
  112.    }
  113.    else lasterror=rc;   /* save an I/O error for UNIXERROR() */
  114.    if(call||catch){
  115.       if(sigdata[bit])free(sigdata[bit]);
  116.       strcpy(sigdata[bit]=allocm(strlen(desc)),desc);
  117.    }
  118.    if(call)delayed[bit]=1;
  119.    else if(catch)die(type);
  120. }
  121.  
  122. void printrc(i) /* Print a trace line showing the return code */
  123. int i;
  124. {
  125.    fprintf(traceout,"      +++ RC=%d +++\n",i);
  126. }
  127.  
  128. /* Variable handling routines */
  129. /* The following routines are low-level and serve to abstract from the
  130.    variables' actual representation. As long as the following routines
  131.    are correct, the representation may be changed without affecting
  132.    the rest of the program. */
  133.  
  134. /* These routines maintain a multiple-level variable table, containing
  135.    names and values of variables. The names of simple symbols and stems
  136.    are kept in a binary tree arrangement, in the format of a varent
  137.    structure followed by a name (padded to a multiple of 4 bytes) and a
  138.    value. Symbols which have been DROPped still exist, but have a value
  139.    length of -1. Symbols which are copies of variables in earlier levels
  140.    have a negative "valalloc" value indicating the level number (starting
  141.    at -1, which means level 0).
  142.    Stems have no trailing dot, but have bit 7 of the first character
  143.    inverted, and the value of a stem is a structure containing a default
  144.    value (an allocated,length,value triple) followed by a binary
  145.    tree of tails associated with values as in the main table
  146.    The binary tree structure should allow access in O(log n) time, except
  147.    when the value pointers need to be updated (when lengthening or
  148.    shortening a value). However no fancy balancing tricks are used, so
  149.    O(n) time is possible in the worst case. A special order is imposed
  150.    which should minimise the possibility of a very unbalanced tree. In
  151.    particular, assigning the letters a-i or the numbers 0-9 in order
  152.    should produce an optimal depth tree (whereas with the usual ordering
  153.    a linear depth tree results).
  154.    The less and grtr fields contain offsets from the start of the level, and
  155.    the next field contains the length of one variable entry. When a variable
  156.    is lengthened or shortened, its own next field is updated, and the less
  157.    and grtr fields of all variables in the same level are updated. All other
  158.    pointers, except for the pointers to each level, remain the same.
  159. */
  160. int less(s1,s2,n1,n2)/* the ordering - compare s1,len n1 with s2,len n2*/
  161. char *s1,*s2;        /* return -ve (s1<s2), 0 (s1=s2) or +ve (s1>s2). */
  162. int n1,n2;
  163. {
  164.    static char xlate[]={4,7,3,11,1,5,9,13,0,2,6,8,10,12,15,14};
  165.            /* the translation table for ordering */
  166.    char x,y;
  167.    if(n1!=n2)return n1-n2;           /* Order on lengths first (it's faster) */
  168.    if(!n1)return 0;                  /* "" == "" */
  169.    while(n1--&&s1++[0]==s2++[0]);    /* find first non-match character */
  170.    x=s1[-1],y=s2[-1];
  171.    x=(x&0xf0)|xlate[x&0xf],          /* translate last characters */
  172.    y=(y&0xf0)|xlate[y&0xf];
  173.    return x-y;                       /* compare last characters */
  174. }
  175.  
  176. char *varsearch(name,len,level,exist)
  177. char *name;
  178. int len;
  179. int *level;
  180. int *exist;
  181. /* search for name `name' of length `len' in the variable table for `level'.
  182.    The answer is the address of the entry which matches, with `exist'
  183.    non-zero, or, if the name does not exist, exist=0 and the answer
  184.    is the address of the slot where the new branch of the tree is to
  185.    be added. If there are no names in the table, 0 is returned.
  186.    On exit, level contains the level number where the variable was actually
  187.    found, which may be different from the given level due to exposure */
  188. {
  189.    char *data=varstk[*level]+vartab;
  190.    char *ans=data;
  191.    int *slot;
  192.    int c;
  193.    *exist=0;
  194.    if(varstk[*level]==varstk[*level+1])return cnull;
  195.    while((c=less(name,ans+sizeof(varent),len,((varent *)ans)->namelen))
  196.      &&  (*(slot= &(((varent *)ans)->less)+(c>0)))>=0)
  197.       ans=data+*slot;   /* Go down the tree */
  198.    if(!c){              /* Equality resulted from the compare */
  199.       *exist=1;
  200.       if((c=((varent *)ans)->valalloc)<0){  /* An exposed variable */
  201.          *level= -(c+1);
  202.          return varsearch(name,len,level,exist);
  203.       }
  204.       else return ans;
  205.    }
  206.    return (char *)slot;
  207. }
  208.  
  209. char *tailsearch(stem,name,len,exist)/* like varsearch, but searches for the */
  210. char *stem,*name;                    /* tail of a compound variable.         */
  211. int len,*exist;
  212. {
  213.    char *data=stem+sizeof(varent)+align(((varent *)stem)->namelen);
  214.    char *tails=data+2*four+*(int *)data; /* start of tail information */
  215.    char *ans=tails;
  216.    int *slot;
  217.    int c;
  218.    *exist=0;
  219.    if(((varent *)stem)->vallen==tails-data)return cnull;
  220.    while((c=less(name,ans+sizeof(varent),len,((varent *)ans)->namelen))
  221.      &&  (*(slot= &(((varent *)ans)->less)+(c>0)))>=0)
  222.       ans=tails+*slot;
  223.    if(c)return (char* )slot;
  224.    *exist=1;
  225.    return ans;
  226. }
  227.  
  228. char *valuesearch(name,namelen,level,exist,stem) /* search for any variable */
  229. char *name;              /* if a simple symbol, the result is like varsearch*/
  230. int namelen;             /* and stem=0. If a compound symbol, level ends up */
  231. int *level,*exist;       /* with the level containing the whole symbol and  */
  232. char **stem;             /* stem points to the stem containing it. exist is */
  233.                          /* non-zero if the whole symbol was found; stem is */
  234.                          /* non-zero if a stem was found, even if it does   */
  235.                          /* not contain the required tail. The return value */
  236.                          /* is the variable entry (if exist), or a slot in  */
  237.                          /* which to put the new tail (if stem && !exist),  */
  238.                          /* or a slot in which to put the new stem (if      */
  239.                          /* !stem). The answer is zero if there are no      */
  240.                          /* entries in the stem (if stem) or if there are no*/
  241.                          /* entries in the vartable (if !stem).             */
  242.              /* If the variable name is an existing stem, 0 is  */
  243. {             /* returned with exist=0 and stem pointing to it   */
  244.    char *ans;
  245.    char *tail;
  246.    int stemlen;
  247.    int taillen;
  248.    register int l;
  249.    if(!(name[0]&128))   /* if a simple symbol, the result is like varsearch */
  250.       return *stem=0,varsearch(name,namelen,level,exist);
  251.    stemlen=(tail=memchr(name,'.',namelen))-name;
  252.    if(!tail)stemlen=namelen,taillen=0;
  253.    else tail++,taillen=namelen-stemlen-1;
  254.    while(1){
  255.       if(!(*stem=varsearch(name,stemlen,level,exist))) return 0; /* no vars */
  256.       if(!*exist) return ans= *stem,*stem=0,ans;                 /* no stem */
  257.       if(!tail) return (*exist=0),cnull;                  /* name is a stem */
  258.       if(!(ans=tailsearch(*stem,tail,taillen,exist)))return 0;  /* no tails */
  259.       if(!*exist)return ans;                                    /* no tail  */
  260.       if((l=((varent *)ans)->valalloc)>=0)return ans;          /* it's here */
  261.       *level=-(l+1);                                      /* it's elsewhere */
  262.    }
  263. }
  264.  
  265. void printtree(lev) /* for testing */
  266. int lev;
  267. {
  268.    varent *v;
  269.    char *c,*d;
  270.    int level=lev;
  271.    int i;
  272.    if(level<0||level>varstkptr)level=varstkptr; /* guard against parameterless
  273.                                        call */
  274.    v=(varent *)(vartab+varstk[level]),c=vartab+varstk[level+1];
  275.    while((char *)v<c){
  276.       printf("Offset:%d\n",((char *)v)-vartab-varstk[level]),
  277.       printf("   next=%d\n",v->next),
  278.       printf("   less=%d\n",v->less),
  279.       printf("   grtr=%d\n",v->grtr),
  280.       printf("   namelen=%d\n",v->namelen),
  281.       printf("   valalloc=%d\n",v->valalloc),
  282.       printf("   vallen=%d\n",v->vallen),
  283.       printf("   name="),
  284.       i=v->namelen,
  285.       d=sizeof(varent)+(char *)v;
  286.       while(i-->0)putchar(d++[0]&127);
  287.       putchar('\n');
  288.       v=(varent *)(v->next+(char *)v);
  289.    }
  290. }
  291.  
  292. void printtails(stem) /* for testing */
  293. varent *stem;
  294. {
  295.    varent *v;
  296.    char *c,*d,*e;
  297.    int i;
  298.    c=(char *)(stem+1)+align(stem->namelen);
  299.    printf("Default value alloc %d len %d value %s\n",*(int*)c,*((int *)c+1),
  300.       *((int *)c+1)<0?"":c+2*four);
  301.    d=c+*(int *)c+2*four,
  302.    v=(varent *)d,c+=stem->vallen;
  303.    while((char *)v<c){
  304.       printf("Offset:%d\n",((char *)v)-d),
  305.       printf("   next=%d\n",v->next),
  306.       printf("   less=%d\n",v->less),
  307.       printf("   grtr=%d\n",v->grtr),
  308.       printf("   namelen=%d\n",v->namelen),
  309.       printf("   valalloc=%d\n",v->valalloc),
  310.       printf("   vallen=%d\n",v->vallen),
  311.       printf("   name="),
  312.       i=v->namelen,
  313.       e=sizeof(varent)+(char *)v;
  314.       while(i-->0)putchar(e++[0]&127);
  315.       putchar('\n');
  316.       v=(varent *)(v->next+(char *)v);
  317.    }
  318. }
  319.  
  320. void update(value,amount,level)
  321. int value,amount,level;
  322. { /* update all the less/grtr fields of level `level' by `amount' if greater
  323.      than `value'; adjust the level pointers also. This routine is called
  324.      *after* the space has been created or reclaimed. */
  325.    register varent *ptr;
  326.    int l=level;
  327.    while(l++<=varstkptr)varstk[l]+=amount;
  328.    for(  ptr=(varent *)(vartab+varstk[level]);
  329.          (char *)ptr<vartab+varstk[level+1];
  330.          ptr=(varent *)((char *)ptr+ptr->next))
  331.    {
  332.       if(ptr->less>value)ptr->less+=amount;
  333.       if(ptr->grtr>value)ptr->grtr+=amount;
  334.    }
  335. }
  336.  
  337. long makeroom(var,amount,level) /* var points to a (complete) variable entry */
  338. int var,amount,level;           /* which is to be enlarged by amount. var is */
  339. {                               /* an integer offset from the start of level */
  340.    register char *i;            /* the return is the difference from dtest   */
  341.    register char *j;
  342.    varent *k;
  343.    char *mtest_old;
  344.    long mtest_diff;
  345.    if(!dtest(vartab,vartablen,varstk[varstkptr+1]+amount+2,amount+512))
  346.       mtest_diff=0;
  347.    k=((varent *)(j=vartab+varstk[level]+var));  /* the variable's address */
  348.    j+=(k->next);                                /* the end of the variable */
  349.    for(i=vartab+varstk[varstkptr+1]-1;i>=j;i--)i[amount]=i[0]; /* make room */
  350.    k->next+=amount;
  351.    update(var,amount,level);
  352.    return mtest_diff;
  353. }
  354.  
  355. void reclaim(var,amount,level)  /* var points to a (complete) variable entry */
  356. int var,amount,level;           /* which is to be reduced by amount. var is  */
  357. {                               /* an integer offset from the start of level */
  358.    register char *i;
  359.    register char *j=vartab+varstk[varstkptr+1]-amount;
  360.    varent *k=(varent *)(vartab+varstk[level]+var);
  361.    for(i=(char *)k+(k->next)-amount;i<j;i++)i[0]=i[amount];
  362.    k->next-=amount;
  363.    update(var,-amount,level);
  364. }
  365.  
  366. void tailupdate(stem,value,amount)
  367. varent *stem;     /* update all the grtr/less fields of the variable pointed */
  368. int value,amount; /* to by stem by amount if greater than value. Updates the */
  369. {                 /* vallen field of the stem also.                          */
  370.    register varent *ptr;
  371.    int len;
  372.    char *data=(char *)stem+sizeof(varent)+align(stem->namelen);
  373.    len=(stem->vallen+=amount);
  374.    for(  ptr=(varent *)(data+*(int *)data+2*four);
  375.          (char *)ptr<data+len;
  376.      ptr=(varent *)((char *)ptr+ptr->next))
  377.    {
  378.       if(ptr->less>value)ptr->less+=amount;
  379.       if(ptr->grtr>value)ptr->grtr+=amount;
  380.    }
  381. }
  382.  
  383. long tailroom(stem,var,amount,level) /* make room in the tail of a stem */
  384. varent *stem;       /* var is a tail offset value, or -1 meaning the default */
  385. int var,amount,level;
  386. {
  387.    register char *i;
  388.    register char *j;
  389.    varent *k;
  390.    char *data;
  391.    char *def;
  392.    long diff=0;
  393.    int ext;
  394.    if(stem->vallen+amount>stem->valalloc)  /* Not enough space allocated */
  395.       ext=align(stem->vallen/3+amount*4/3),
  396.       diff=makeroom((char *)stem-vartab-varstk[level],ext,level),
  397.       stem=(varent *)((char *)stem+diff),
  398.       stem->valalloc+=ext;                 /* It is now!                 */
  399.    def=data=(char *)stem+sizeof(varent)+align(stem->namelen);
  400.    data+=*(int *)data+2*four;
  401.    if(var>=0)k=(varent *)(j=data+var),  /* find the tail, and its end */
  402.              j+=(k->next);
  403.    else k=(varent *)(j=data);           /* or use the default value */
  404.    for(i=def+stem->vallen-1;i>=j;i--)i[amount]=i[0];
  405.    if(var>=0)k->next+=amount,
  406.              tailupdate(stem,var,amount);
  407.    else *(int *)def +=amount;
  408.    return diff;
  409. }
  410.  
  411. void tailreclaim(stem,var,amount) /* Reduce the size of a tail element */
  412. int var,amount;                   /* var is a tail offset value */
  413. varent *stem;
  414. {
  415.    register char *i;
  416.    register char *j;
  417.    varent *k;
  418.    char *data;
  419.    data=(char *)stem+sizeof(varent)+align(stem->namelen);
  420.    j=data+stem->vallen-amount;
  421.    data+=*(int *)data+2*four;
  422.    k=(varent *)(data+var);
  423.    for(i=(char *)k+(k->next)-amount;i<j;i++)i[0]=i[amount];
  424.    k->next-=amount;
  425.    tailupdate(stem,var,-amount);
  426. }
  427.  
  428. void tailhookup(stem)   /* hook up the tree structure within a stem */
  429. varent *stem;           /* i.e. fill in the grtr & less fields in a list */
  430. {                       /* of tail elements */
  431.    int *slot;
  432.    int exist;
  433.    register char *k;
  434.    char *data=(char *)(stem+1)+align(stem->namelen);/*address of stem's value*/
  435.    char *tails=data+*(int *)data+2*four;            /* address of first tail */
  436.    char *end=data+stem->vallen;                     /* end of last tail */
  437.    for(k=tails;k<end;k+=((varent *)k)->next){
  438.       if(k==tails)continue;
  439.       slot=(int *)tailsearch/* should always tell where to hook the new tail */
  440.          ((char*)stem,k+sizeof(varent),((varent *)k)->namelen,&exist);
  441.       if(!exist) /* should always be true! */ slot[0]=k-tails;
  442.    }
  443. }
  444.  
  445. void varcreate(varptr,name,value,namelen,len,lev)
  446. char *varptr,*name,*value;         /* create a new variable (used in varset */
  447. int namelen,len,lev;               /* and varcopy) with given value.        */
  448.                                    /* varptr is the result of a failed      */
  449.                                    /* search, i.e. if non-null points to an */
  450.                                    /* integer slot to store the address.    */
  451.                                    /* if lev=0, place in the top level. If  */
  452.                                    /* lev=1, place one level down.          */
  453. {
  454.    int alloc=len/4;
  455.    int ext;
  456.    register char *i;
  457.    register char *v;
  458.    long mtest_diff;
  459.    char *mtest_old;
  460.    if(alloc<20)alloc=20;  /* The extra amount of space to allocate */
  461.    alloc+=len,
  462.    alloc=align(alloc);    /* The total amount of space to allocate */
  463.    if dtest(vartab,
  464.             vartablen,
  465.             varstk[varstkptr+1]+1+(ext=align(alloc+namelen+sizeof(varent))),
  466.             namelen+alloc+256)
  467.       if(varptr)varptr+=mtest_diff;
  468.    v=vartab+varstk[varstkptr+!lev];      /* where to put the new variable */
  469.    if(lev)  /* move up the entire top level to make room */
  470.       for(i=vartab+varstk[varstkptr+1];i>=v;i--)i[ext]=i[0];
  471.    memcpy(v+sizeof(varent),name,namelen),/* copy the variable's name  */
  472.    ((varent *)v)->next=ext,              /* now fill in the fields... */
  473.    ((varent *)v)->less= -1,
  474.    ((varent *)v)->grtr= -1,
  475.    ((varent *)v)->namelen=namelen,
  476.    ((varent *)v)->valalloc=alloc,
  477.    ((varent *)v)->vallen=len;
  478.    if(varptr)             /* make the new variable a part of the tree */
  479.       *(int *)varptr=varstk[varstkptr+!lev]-varstk[varstkptr-lev];
  480.    if(len>0)                       /* copy the new variable's value */
  481.       memcpy(v+sizeof(varent)+align(namelen),value,len);
  482.    varstk[varstkptr+1]+=ext;       /* and finally update the level pointers */
  483.    if(lev)varstk[varstkptr]+=ext;
  484. }
  485.  
  486. void stemcreate(varptr,name,value,namelen,len,lev)
  487. char *varptr,*name,*value;         /* similar to varcreate(), but a whole   */
  488. int namelen,len,lev;               /* stem is created with the given default*/
  489.                                    /* name does not include the dot */
  490. {
  491.    int alloc=align(len*5/4+256);
  492.    int ext;
  493.    register char *i,*v;
  494.    long mtest_diff;
  495.    char *mtest_old;
  496.    if dtest(vartab,
  497.         vartablen,
  498.         varstk[varstkptr+1]+1+(ext=align(alloc+namelen+sizeof(varent)+2*four)),
  499.     namelen+alloc+256)
  500.       if(varptr)varptr+=mtest_diff;
  501.    v=vartab+varstk[varstkptr+!lev];
  502.    if(lev)for(i=vartab+varstk[varstkptr+1];i>=v;i--)i[ext]=i[0];
  503.    memcpy(v+sizeof(varent),name,namelen);
  504.    if(varptr) *(int *)varptr=varstk[varstkptr+!lev]-varstk[varstkptr-lev];
  505.    ((varent *)v)->next=ext,
  506.    ((varent *)v)->less= -1,
  507.    ((varent *)v)->grtr= -1,
  508.    ((varent *)v)->namelen=namelen,
  509.    ((varent *)v)->valalloc=alloc,
  510.    ((varent *)v)->vallen=(alloc=align(len))+2*four;
  511.    v+=sizeof(varent)+align(namelen),
  512.    ((int *)v)[0]=alloc,
  513.    ((int *)v)[1]=len;
  514.    if(len>0)memcpy(v+2*four,value,len);
  515.    varstk[varstkptr+1]+=ext;
  516.    if(lev)varstk[varstkptr]+=ext;
  517. }
  518.  
  519. void tailcreate(stem,tailptr,name,value,namelen,len,level)
  520. char *stem,*tailptr,*name,*value;  /* create new tail within a stem with */
  521. int namelen,len,level;             /* a given value. Stem is the address */
  522.                                    /* of the stem structure, tailptr is  */
  523.                                    /* the equivalent of varptr in earlier*/
  524.                                    /* functions. Level is the actual     */
  525.                                    /* level number. */
  526. {
  527.    long diff;
  528.    int alloc=len/4;
  529.    int ext;
  530.    char *v=stem+sizeof(varent)+align(((varent *)stem)->namelen);
  531.    char *e=v+((varent *)stem)->vallen;  /* end of last tail */
  532.    v+=*(int *)v+2*four;                 /* start of first tail */
  533.    if(len<0)alloc=0;
  534.    else {
  535.       if(alloc<20)alloc=20;
  536.       alloc=align(alloc+len);
  537.    }
  538.    if(   (ext=alloc+align(namelen)+sizeof(varent))
  539.        + ((varent *)stem)->vallen
  540.      >   ((varent *)stem)->valalloc){
  541.       if(diff=makeroom(stem-vartab-varstk[level],ext+256,level)){
  542.          if(tailptr)tailptr+=diff;
  543.          stem+=diff,e+=diff,v+=diff;
  544.       }
  545.       ((varent *)stem)->valalloc+=ext+256;
  546.    }
  547.    if(tailptr)*(int *)(tailptr)=e-v; /* Save the offset in the parent's slot */
  548.    memcpy(e+sizeof(varent),name,namelen), /* Make the new tail at e */
  549.    ((varent *)e)->next=ext,
  550.    ((varent *)e)->less= -1,
  551.    ((varent *)e)->grtr= -1,
  552.    ((varent *)e)->namelen=namelen,
  553.    ((varent *)e)->valalloc=alloc,
  554.    ((varent *)e)->vallen=len;
  555.    if(len>0)memcpy(e+sizeof(varent)+align(namelen),value,len);
  556.    ((varent *)stem)->vallen+=ext;
  557. }
  558.  
  559. void varset(name,varlen,value,len) /* set variable `name' of namelength   */
  560. char *name,*value;                 /* `varlen' equal to the value `value' */
  561. int len,varlen;                    /* which has length `len'              */
  562. {
  563.    int varalloc,varoff,ext,newlen,exist;
  564.    register char *i;
  565.    register varent *v1,*v2;
  566.    int level=varstkptr;
  567.    char *valptr;
  568.    char *varptr;
  569.    char *oldptr;
  570.    char *stemptr;
  571.    long diff;
  572.    int compound=name[0]&128;
  573.    int isstem=compound&&!memchr(name,'.',varlen);/* stems do not contain dots*/
  574.    char varname[maxvarname];
  575.    if(isstem){ /* Set the default value of a whole stem. */
  576.       varptr=varsearch(name,varlen,&level,&exist);
  577.       if(exist){ /* stem exists. Set default and clear all non-exposed tails */
  578.          valptr=varptr+sizeof(varent)+align(((varent *)varptr)->namelen);
  579.         /* valptr points to the default value */
  580.          if((ext=align(len-*(int *)valptr))>0)/* extra mem needed for default*/
  581.             if(diff=tailroom((varent *)varptr,-1,ext,level))
  582.                varptr+=diff,
  583.                valptr+=diff;
  584.          ((int *)valptr)[1]=len;  /* now copy the default value */
  585.          if(len>0)memcpy(valptr+2*four,value,len);
  586.          ext= *(int *)valptr;
  587.          i=((varent *)varptr)->vallen+valptr; /* the end of the last tail */
  588.          v2=(varent *)(valptr+2*four+ext);    /* the start of the first tail */
  589.          oldptr=valptr;
  590.          valptr+= (*(int *)valptr=align(len))+2*four; /* new start of tails */
  591.          v1=(varent *)valptr;              /* pointer to "current" new tail */
  592.          /* now copy all exposed tails from v2 to v1. upper bound of v2 = i */
  593.          while((char *)v2<i){
  594.             if(v2->valalloc<0)  /* It is exposed */
  595.                memcpy((char*)v1,(char*)v2,v2->next),
  596.                v1->grtr= -1,
  597.                v1->less= -1,
  598.                v1=(varent *)((char *)v1+v1->next);
  599.             v2=(varent *)((char *)v2+v2->next);
  600.          }
  601.          ((varent *)varptr)->vallen=ext=((char *)v1)-oldptr; /* new length */
  602.          ext=align(ext);      /* The amount of space to leave in this stem */
  603.          if(len>=0)ext+=256;  /* Leave some extra space for future tails   */
  604.          if((ext-=((varent *)varptr)->valalloc)<0)      /* Shrink the stem */
  605.             reclaim(varptr-varstk[level]-vartab,-ext,level),
  606.             ((varent *)varptr)->valalloc+=ext;
  607.          /* hook up the tree of tails */
  608.          tailhookup((varent*)varptr);
  609.          /* assign the given string to each remaining tail */
  610.          memcpy(varname,name,varlen); /* varname holds each compund symbol */
  611.      varname[varlen]='.';
  612.          for(v2=(varent *)valptr;v2<v1;v2=(varent *)((char *)v2+v2->next))
  613.             memcpy(varname+varlen+1,(char*)(v2+1),v2->namelen),
  614.             varset(varname,varlen+v2->namelen,value,len);
  615.          return;
  616.       }
  617.       /* a stem which does not exist is being initialised */
  618.       if(len>=0)stemcreate(varptr,name,value,varlen,len,0);
  619.       return;
  620.    }
  621.    if(compound){  /* A compound symbol is being assigned to */
  622.       varptr=valuesearch(name,varlen,&level,&exist,&stemptr);
  623.       if(exist){ /* change an existing compound variable */
  624.          valptr=stemptr+sizeof(varent)+align(((varent *)stemptr)->namelen),
  625.          valptr+=*(int *)valptr+2*four;
  626.          varoff=varptr-valptr, /* now varoff contains the offset within stem */
  627.          varalloc= ((varent *)varptr)->valalloc;
  628.          if(len>varalloc){     /* need some more memory */
  629.             ext=len/4;
  630.             if(ext<20)ext=20;
  631.             newlen=align(len+ext), /* the total amount of memory */
  632.             ext=newlen-varalloc;   /* the extra amount */
  633.             varptr+=tailroom((varent*)stemptr,varoff,ext,level);
  634.             ((varent *)varptr)->valalloc=newlen;
  635.          }
  636.          else if(len<0&&varalloc>10)  /* variable is being dropped - reclaim */
  637.             tailreclaim((varent*)stemptr,varoff,varalloc),
  638.             ((varent *)varptr)->valalloc=0;
  639.          if(len>0) /* Copy the value */
  640.         memcpy(varptr+sizeof(varent)+align(((varent *)varptr)->namelen),
  641.                value,len);
  642.          ((varent *)varptr)->vallen=len; /* and copy the length */
  643.          return;
  644.       }
  645.       if(!stemptr){/* the stem does not exist. Create then continue */
  646.          if(len<0)return; /* Do not bother to DROP from a nonexistent stem */
  647.          stemcreate(varptr,name,cnull,strchr(name,'.')-name,-1,0),
  648.             /* create stem with no default (the above line) */
  649.          level=varstkptr,
  650.          varptr=valuesearch(name,varlen,&level,&exist,&stemptr);
  651.             /* the search is guaranteed to find a stem with no tail */
  652.       }
  653.       /* the stem exists but the tail does not */
  654.       /* Even if the variable is being dropped, it is necessary to create it
  655.          in case of e.g. "a.=5; drop a.1; say a.1" (should say "A.1") */
  656.       oldptr=name,
  657.       varlen-=((name=1+strchr(name,'.'))-oldptr);
  658.       tailcreate(stemptr,varptr,name,value,varlen,len,level);
  659.       return;
  660.    } /* So now it is a simple symbol. */
  661.    varptr=varsearch(name,varlen,&level,&exist);
  662.    if(exist){ /* variable exists, so reset */
  663.       varoff= varptr-vartab-varstk[level],
  664.       varalloc= ((varent *)varptr)->valalloc;
  665.       if(len>varalloc){
  666.          ext=len/4;
  667.          if(ext<20)ext=20;
  668.          newlen=align(len+ext),
  669.          ext=newlen-varalloc;
  670.          varptr+=makeroom(varoff,ext,level);
  671.          ((varent *)varptr)->valalloc=newlen;
  672.       }
  673.       else if(len<0&&varalloc>10)  /* variable is being dropped - reclaim */
  674.          reclaim(varoff,varalloc,level),
  675.          ((varent *)varptr)->valalloc=0;
  676.       if(len>0)
  677.          memcpy(varptr+sizeof(varent)+align(((varent *)varptr)->namelen),
  678.      value,len);
  679.       ((varent *)varptr)->vallen=len;
  680.    }
  681.    else if(len>=0) /* variable does not exist, so create */
  682.       varcreate(varptr,name,value,varlen,len,0);
  683. }
  684.  
  685. char *varget(name,varlen,len)/* get value and length of variable `name'.     */
  686. char *name;                  /* Value is returned, length is placed in `len' */
  687. int varlen;
  688. int *len;
  689. {
  690.    int level=varstkptr;
  691.    char *stem;
  692.    char *varptr=valuesearch(name,varlen,&level,len,&stem);
  693.    if(!(*len||stem))return 0;    /* does not exist at all */
  694.    if(*len&&stem&&((varent *)varptr)->vallen<0)
  695.       return (*len=0),cnull;     /* compound symbol has "null" value */
  696.    if(!*len){
  697.       /* compound variable doesn't exist; try default value */
  698.       stem+=sizeof(varent)+align(((varent *)stem)->namelen);
  699.       if((*len= *((int *)stem+1))>=0) return stem+2*four;
  700.       else return (*len=0),cnull;
  701.    }
  702.    if((*len= ((varent *)varptr)->vallen)>=0) /* exists */
  703.       return varptr+align(((varent *)varptr)->namelen)+sizeof(varent);
  704.    else return (*len=0),cnull;
  705. }
  706.  
  707. void newlevel()    /* increment variable level, making a clean environment  */
  708. {
  709.    char *charvarstk=(char *)varstk;
  710.    mtest(charvarstk,varstklen,four*(++varstkptr+2),four*25);
  711.    varstk=(int *)charvarstk;
  712.    varstk[varstkptr+1]=varstk[varstkptr];
  713. }
  714.  
  715. void varcopy(name,varlen) /* copy a variable (as in procedure expose)       */
  716. int varlen;
  717. char *name;        /* when this procedure is called, varstkptr has already  */
  718. {                  /* been incremented to point to the level in which the new
  719.                       copy of the variable is required. The old copy of the
  720.                       variable will be in level varstkptr-1.                */
  721.    int ext,l;
  722.    register char *i;
  723.    char *oldptr;
  724.    int level=varstkptr-1;
  725.    int compound=name[0]&128;
  726.    int isstem=compound&&!memchr(name,'.',varlen);
  727.    char *varptr;
  728.    char *stemptr;
  729.    char *endvar;
  730.    char *mtest_old;
  731.    long mtest_diff;
  732.    if(compound&&!isstem){ /* An individual compound symbol */
  733.       varptr=valuesearch(name,varlen,&level,&l,&stemptr);
  734.       if(!l){ /* compound variable does not exist, so create before exposing */
  735.          if(!stemptr) /* stem does not exist, so create with no default */
  736.             stemcreate(varptr,name,cnull,strchr(name,'.')-name,-1,1),
  737.             level=varstkptr-1,
  738.             varptr=valuesearch(name,varlen,&level,&l,&stemptr);
  739.          oldptr=1+strchr(name,'.'),
  740.          tailcreate(stemptr,varptr,oldptr,cnull,varlen-(oldptr-name),-1,level);
  741.       }
  742.       /* now copy the variable, which is in level `level' */
  743.       ext=varstkptr;
  744.       varptr=valuesearch(name,varlen,&ext,&l,&stemptr);
  745.       if(!l){/* not already exposed, so go ahead */
  746.          /* make sure there is a stem to hold the new variable */
  747.          if(!stemptr)
  748.             stemcreate(varptr,name,cnull,strchr(name,'.')-name,-1,0),
  749.                /* create stem with no default */
  750.             ext=varstkptr,
  751.             varptr=valuesearch(name,varlen,&ext,&l,&stemptr);
  752.          if(ext==varstkptr&&((varent *)stemptr)->valalloc>=0){
  753.             /* stem is not already exposed, so go ahead */
  754.             oldptr=name,name=1+strchr(name,'.'),varlen-=name-oldptr,
  755.             ext=sizeof(varent)+align(varlen),
  756.             oldptr=vartab;
  757.             if(((varent *)stemptr)->valalloc<((varent *)stemptr)->vallen+ext){
  758.                if(mtest_diff
  759.            =makeroom(stemptr-vartab-varstk[varstkptr],ext+256,varstkptr)){
  760.                   if(varptr)varptr+=mtest_diff;
  761.                   stemptr+=mtest_diff;
  762.                }
  763.                ((varent *)stemptr)->valalloc+=ext+256;
  764.             } /* There is now enough room to place the new tail at the end
  765.           of the stem. */
  766.             i=stemptr+sizeof(varent)+align(((varent *)stemptr)->namelen),
  767.             endvar=i+((varent *)stemptr)->vallen,
  768.             i+= *(int*)i+2*four,
  769.             ((varent *)stemptr)->vallen+=ext;
  770.             if(varptr)*(int *)varptr=endvar-i;
  771.             memcpy(endvar+sizeof(varent),name,varlen),
  772.             ((varent *)endvar)->next=ext,
  773.             ((varent *)endvar)->less= -1,
  774.             ((varent *)endvar)->grtr= -1,
  775.             ((varent *)endvar)->namelen=varlen,
  776.             ((varent *)endvar)->valalloc= -(level+1),
  777.             ((varent *)endvar)->vallen=0;
  778.          }
  779.       }
  780.       return;
  781.    }
  782.    /* stems are like ordinary symbols; both are treated here. */
  783.    varptr=varsearch(name,varlen,&level,&l);
  784.    if(!l) /* create in old level before exposing to new level */
  785.       if(isstem) stemcreate(varptr,name,cnull,varlen,-1,1);
  786.       else        varcreate(varptr,name,cnull,varlen,-1,1);
  787.    ext=varstkptr;
  788.    varptr=varsearch(name,varlen,&ext,&l);
  789.    if(!l){ /* not already exposed, so go ahead */
  790.       if dtest(vartab,vartablen,varstk[varstkptr+1]+1+(ext=sizeof(varent)+align(varlen)),varlen+256)
  791.          if(varptr)varptr+=mtest_diff;
  792.       ((varent *)(i=vartab+varstk[varstkptr+1]))->less= -1,
  793.       ((varent *)i)->grtr= -1,
  794.       ((varent *)i)->next=ext,
  795.       ((varent *)i)->namelen=varlen,
  796.       ((varent *)i)->valalloc= -(level+1),
  797.       ((varent *)i)->vallen=0;
  798.       if(varptr)*(int *)varptr=varstk[varstkptr+1]-varstk[varstkptr];
  799.       varstk[varstkptr+1]+=ext;
  800.       memcpy(i+sizeof(varent),name,varlen);
  801.    }
  802. }
  803.  
  804. void vardup() /* make an exact copy of the variables to pass into the
  805.                  next procedure */
  806. {
  807.    int ext=varstk[varstkptr]-varstk[varstkptr-1];
  808.    int exist;
  809.    int *slot;
  810.    register char *i,*j,*k;
  811.    /* test for memory. The new level requires no more memory than the
  812.       previous one */
  813.    mtest(vartab,vartablen,varstk[varstkptr+1]+ext+1,ext+10);
  814.    /* Compress the old variables into the new level */
  815.    i=vartab+varstk[varstkptr-1],
  816.    j=k=vartab+varstk[varstkptr];
  817.    while(i<j){
  818.       memcpy(k,i,ext=sizeof(varent)+align(((varent *)i)->namelen));
  819.       if(((varent *)k)->valalloc>=0)((varent *)k)->valalloc= -varstkptr;
  820.       ((varent *)k)->next= ext,
  821.       ((varent *)k)->less= -1,
  822.       ((varent *)k)->grtr= -1,
  823.       ((varent *)k)->vallen= 0,
  824.       k+=ext;
  825.       i+=((varent *)i)->next;
  826.    }
  827.    varstk[varstkptr+1]=k-vartab;
  828.    /* hook up the tree structure */
  829.    for(i=k,k=j;k<i;k+=((varent *)k)->next){
  830.       if(k==j)continue;
  831.       ext=varstkptr;
  832.       slot=(int *)varsearch(k+sizeof(varent),((varent *)k)->namelen,&ext,&exist);
  833.       if(!exist) /* should always be true! */ slot[0]=k-j;
  834.    }
  835. }
  836.  
  837. void vardel(name,len) /* delete name (as in procedure hide) */
  838. int len;
  839. char *name;       /* the name is not deleted, rather given a new */
  840. {                 /* undefined value (to avoid massive restructuring)*/
  841.    int compound=name[0]&128;
  842.    int isstem=compound&&!memchr(name,'.',len);
  843.    int *slot;
  844.    int c;
  845.    char *ans=vartab+varstk[varstkptr];
  846.    if(compound&&!isstem)die(Ebadexpr);
  847.    while((c=less(name,ans+sizeof(varent),len,((varent *)ans)->namelen))&&(*(slot=(int *)ans+1+(c>0)))>=0)ans=vartab+varstk[varstkptr]+*slot;
  848.    if(!c){
  849.       ((varent *)ans)->valalloc=0;
  850.       if(isstem)
  851.          ans+=tailroom((varent*)ans,-1,2*four,varstkptr),
  852.          slot=(int *)(ans+sizeof(varent)+align(((varent *)ans)->namelen)),
  853.          slot++[0]=0,
  854.          slot[0]=-1,
  855.          ((varent *)ans)->vallen=2*four;
  856.       else ((varent *)ans)->vallen= -1;
  857.    }
  858. }
  859.  
  860. char uc(c)       /* return the upper case of c */
  861. char c;
  862. {
  863.    if(c<'a'||c>'z')return c;
  864.    return c&0xdf;
  865. }
  866.  
  867. void *pstack(type,len) /* stack current position on the program stack,*/
  868. int type,len;          /* returning the address of a stack item to be */
  869. {                      /* filled in */
  870.    register int *answer,*ptr;
  871.    mtest(pstackptr,pstacklen,epstackptr+len+16,256+len);
  872.    *(ptr=answer=(int *)(pstackptr+epstackptr))=ppc, /* Store the first elmnt */
  873.    *(ptr=(int *)(pstackptr+(epstackptr+=len))-1)=type,/* Store the type, and */
  874.    *--ptr=len,                                      /* the length before it  */
  875.    pstacklev++,totpstacklev++;                      /* Record the extra entry*/
  876.    return (void *)answer;
  877. }
  878.  
  879. int unpstack()      /* examine an entry from the program stack */
  880.                     /* without deleting it.  The type is returned.  */
  881. {
  882.    int type;
  883.    register char *ptr=pstackptr+epstackptr;
  884.    type= *((int *)ptr-1);
  885.    ptr-= *((int *)ptr-2);  /* ptr points to the start of the entry */
  886.    newppc=((struct minstack *)ptr)->stmt;
  887.    return type;
  888. }
  889.  
  890. void *delpstack() /* Delete the top program stack entry; return its address */
  891. {
  892.    if(!totpstacklev)return (void *)(pstackptr+(epstackptr=0));
  893.    pstacklev--,totpstacklev--;
  894.    return (void *)(pstackptr+(epstackptr-=*((int *)(pstackptr+epstackptr)-2)));
  895. }
  896.  
  897. int strcmpi(s1,s2)  /* compare s1 & s2 with case independence       */
  898. char *s1,*s2;       /* return 1 if s2 is an initial substring of s2 */
  899. {
  900.    int i;
  901.    for(i=0;s2[i]&&!((s1[i]^s2[i])&0xDF);i++);
  902.    return !s2[i];
  903. }
  904. #if 0
  905. void printstmt(line,st,error)   /* print the source statement indicated */
  906. int line,st,error;              /* if error=1 then precede with +++     */
  907. {
  908.    int i=line; /* temporary */
  909.    char c;
  910.    int spc=0;
  911.    char quote=0;
  912.    char *st1=stmts(&line,st);   /* Find the start and end of the statemtent */
  913.    char *st2=stmts(&i,st+1);    /* in the source code */
  914.    char *st3;
  915.    static char *symwords[]=     /* the symbolic tokens */
  916.       {"||","&&","==","<=",">=","<>","\\==","//","<<",">>","<<=",">>=","**"};
  917.    char *what=error?"+++":"*-*"; /* The trace prefix */
  918.    if(!st)st++;
  919.    if(!line){ /* interpreted ... un-parse the line */
  920.       printf("  --- %s ",what);
  921.       for(i=0;i<traceindent*pstacklev;i++)putchar(' '); /* indent */
  922.       for(st1=interp;--st;){                            /* find statement */
  923.          while((c=st1[0])&&c!=THEN&&c!=-1)st1++;        /* (easy!) */
  924.          if(c&&st1[1]==THEN)st1++;
  925.          if(c)st1++;
  926.       }
  927.       if(!st1[0]){puts("<EOL>");return;}  /* statement doesn't exist */
  928.       while((c=st1[0])&&c!=-1&&c!=THEN){  /* Print up to next terminator */
  929.          if(c<SYMBOL){                    /* Print a word */
  930.             if(spc)putchar(' ');
  931.             for(st2=words[c+128];st2[0];st2++)putchar(st2[0]|0x20);
  932.             putchar(' ');
  933.             spc=0;
  934.          }
  935.          else if(c<0){  /* Print a symbolic token */
  936.             if(spc)putchar(' ');
  937.             printf("%s",symwords[c-(SYMBOL+1)]);
  938.             putchar(' ');
  939.             spc=0;
  940.          }
  941.          else {  /* Print a character; lowercase it if outside quotes */
  942.             if(quote&&c==quote)quote=0;
  943.             else if((c=='\''||c=='\"')&&!quote)quote=c;
  944.             if((c>='A'&&c<='Z')&&!quote)c|=0x20;
  945.             putchar(c);
  946.             spc=(c!=' ');
  947.          }
  948.          st1++;
  949.       }
  950.       if(c==THEN){  /* Print a terminating THEN */
  951.          if(spc)putchar(' ');
  952.          puts("then");
  953.       }
  954.       else putchar('\n');
  955.       return;
  956.    } /* Print a regular source line (or lines) */
  957.    if(st2)if(st2[-1]==';')st2--;      /* Remove a final semicolon */
  958.    if(st1&&st2) /* calculate column at which the stmt starts */
  959.       for(spc=0,st3=(*source)[line];
  960.             st3<st2&&(c=st3[0],st3<st1||c==' '||c=='\t');st3++)
  961.          if(c=='\t')spc=8+(spc&~7);
  962.      else spc++;
  963.    do{
  964.       printf("%5d %s ",line,what);
  965.       for(i=0;i<traceindent*pstacklev;i++)putchar(' '); /* indent */
  966.       if(st1&&st2){           /* Both ends of the statement found, so print */
  967.          for(i=0;i<spc&&st1<st2&&((c=st1[0])==' '||c=='\t');st1++)
  968.         if(c=='\t')i=8+(i&~7);     /* Remove leading spaces */
  969.         else i++;
  970.      while(i>spc)putchar(' '),i--; /* Print part of a tab if necessary */
  971.          for(;st1<st2&&st1[0];st1++)
  972.         printf("%c",st1[0]);  /* Print the statement, up to EOL */
  973.      if(st1<st2&&line<lines)st1=(*source)[++line]; /* Go to next line */
  974.       }
  975.       else if(line>lines)fputs("<EOF>",stdout);  /* Line wasn't found */
  976.       else fputs("<EOL>",stdout);                /* statement wasn't found */
  977.       putchar('\n');
  978.    } while(st1&&st2&&st1<st2&&line<=lines);
  979. }
  980. #endif
  981.  
  982. void freestack(ptr,i)    /* free areas indicated by program stack type i */
  983. void *ptr;               /* stack entry starts at ptr */
  984. int i;
  985. {
  986.    register struct procstack *sptr=(struct procstack *)ptr;
  987.    if(i==13) /* external call - free calc stack and program areas */
  988.       interplev--,
  989.       free(cstackptr),
  990.       cstackptr=sptr->csp,
  991.       cstacklen=sptr->csl,
  992.       ecstackptr=sptr->ecsp,
  993.       timeflag=(timeflag&4)|(sptr->tim &1),
  994.       trcflag=sptr->trc,
  995.       microsecs=sptr->mic,
  996.       secs=sptr->sec,
  997.       numform=sptr->form,
  998.       precision=sptr->digits,
  999.       fuzz=sptr->fuzz,
  1000.       free(source[0]),     /* the file name */
  1001.       free(source[1]),     /* the source characters */
  1002.       free((char*)source),
  1003.       free(prog[0].line),  /* the program characters */
  1004.       free((char*)prog),
  1005.       free(labelptr),
  1006.       lines=sptr->lines,
  1007.       stmts=sptr->stmts,
  1008.       source=sptr->src,
  1009.       prog=sptr->prg,
  1010.       labelptr=sptr->lab,
  1011.       pstacklev=sptr->lev-1;
  1012.    else if(i==11||i==12) /* internal call */
  1013.       interplev--,
  1014.       free(cstackptr),
  1015.       cstackptr=sptr->csp,
  1016.       cstacklen=sptr->csl,
  1017.       ecstackptr=sptr->ecsp,
  1018.       prog=sptr->prg,
  1019.       stmts=sptr->stmts,
  1020.       timeflag=(timeflag&4)|(sptr->tim &1),
  1021.       trcflag=sptr->trc,
  1022.       microsecs=sptr->mic,
  1023.       secs=sptr->sec,
  1024.       numform=sptr->form,
  1025.       precision=sptr->digits,
  1026.       fuzz=sptr->fuzz;
  1027.    else if(i==14) /* interpret */
  1028.       interplev--,
  1029.       free(prog[0].source),  /* the interpreted string */
  1030.       free(prog[0].line),    /* the tokenised string */
  1031.       free((char*)prog),     /* the statement table */
  1032.       stmts=((struct interpstack *)sptr)->stmts,
  1033.       prog=((struct interpstack *)sptr)->prg;
  1034.    else if(i==16) /* interactive() stored calculator stack */
  1035.       free(cstackptr),
  1036.       cstackptr=sptr->csp,
  1037.       cstacklen=sptr->csl,
  1038.       ecstackptr=sptr->ecsp,
  1039.       interact=-1;
  1040.    else if(i==20) /* saved traceback line */
  1041.       prog=((struct errorstack *)sptr)->prg,
  1042.       stmts=((struct errorstack *)sptr)->stmts;
  1043.    if(i==12||i==13) /* reclaim procedural variables */
  1044.       varstkptr--;
  1045.    if(i>=11&&i<=14 && sgstack[interplev+1].data) /* reclaim condition data */
  1046.       free(sgstack[interplev+1].data);
  1047. }
  1048.  
  1049. void interactive() /* interactive tracing - called whenever the tracer might */
  1050. {                  /* want to stop for input */
  1051.    char inbuf[256];
  1052.    char **ocurargs=curargs;   /* Save the arguments to the current procedure */
  1053.    int *ocurarglen=curarglen; /* in case of a trap from a lower procedure */
  1054.    int oppc=ppc;              /* save also the current position */
  1055.    int i;
  1056.    struct interactstack *entry;
  1057.    if((!(trcflag&0x80)) || interact>=0)
  1058.       return;                 /* Continue only in interactive mode */
  1059.    if(interactmsg)
  1060.       interactmsg=0,
  1061.       fputs("      +++ Interactive trace.  TRACE OFF to end debug, ENTER to continue. +++",ttyout),
  1062.       putc('\n',ttyout);
  1063.    entry=(struct interactstack *)pstack(16,sizeof(struct interactstack));
  1064.    entry->csp=cstackptr,      /* Now fill in a program stack entry for the */
  1065.    entry->csl=cstacklen,      /* commands typed in */
  1066.    entry->ecs=ecstackptr;
  1067.    otrcflag=trcflag;
  1068.    cstackptr=allocm(cstacklen=200); /* Make a new calculator stack. */
  1069.    ecstackptr=0;
  1070.    trclp=1;                   /* signal "do wait for more input" */
  1071.    while(trclp){              /* Until the user restarts the program ...*/
  1072.       returnlen=-1;           /* signal that a RETURN was not executed */
  1073.       fputs(">trace>",ttyout),fflush(ttyout);
  1074.       clearerr(ttyin);
  1075.       if(!(fgets(inbuf,256,ttyin)))inbuf[0]=0;
  1076.       else inbuf[strlen(inbuf)-1]=0;
  1077.       returnval=0;
  1078.       if(!inbuf[0])break;     /* No input -> continue with program */
  1079.       interact=interplev;     /* signal "interactive mode" */
  1080.       trcflag=Terrors;        /* turn tracing "off" while interpreting input */
  1081.       if(_setjmp(interactbuf))/* Save the context in case of an error */
  1082.          curargs=ocurargs,    /* error! restore the correct context */
  1083.          curarglen=ocurarglen,
  1084.          ppc=oppc,
  1085.      returnlen=-1;
  1086.       else returnval=rxinterp(inbuf,strlen(inbuf),&returnlen, /* Interpret */
  1087.                               "TRACE","TRACE",curargs,curarglen);
  1088.       if(trclp==1)trcflag=otrcflag; /* Unless the input contained a trace
  1089.                                        command, restore the old trace flag. */
  1090.       if(returnlen>=0)break;  /* Continue with program if a RETURN occurred */
  1091.    }
  1092.    interact= -1;              /* signal "not interactive mode" */
  1093.    if(returnval)returnfree=cstackptr; /* The result's user will free it */
  1094.    else free(cstackptr);      /* Nothing of value was on the stack */
  1095.    while(i=*((int *)(pstackptr+epstackptr)-1)!=16)/* Clear the program stack */
  1096.       freestack(delpstack(),i);
  1097.    entry=(struct interactstack *)delpstack();/* delete interactive()'s entry */
  1098.    cstackptr=entry->csp,                     /* and restore the old stack */
  1099.    ecstackptr=entry->ecs,
  1100.    cstacklen=entry->csl;
  1101.    if(returnlen>=0)      /* if a RETURN occurred, jump back to do the return */
  1102.       _longjmp(sgstack[interplev].jmp,-1);
  1103. }
  1104.  
  1105. /* The following function loads a source file from disk and returns the
  1106.    block of memory allocated to hold it.  The return value is null if 
  1107.    an error occurred. */
  1108. char *load(name,sourcelen)
  1109. char *name;          /* The path name of the program */
  1110. int *sourcelen;      /* The length of the source (to be returned) */
  1111. {
  1112.    struct stat buf;  /* For finding the size of the program */
  1113.    int f= -1;        /* A file descriptor */
  1114.    unsigned size;    /* The size of the program */
  1115.    char *store;      /* The memory allocated to hold the source */
  1116.  
  1117. /* find size of file */
  1118.    if (stat(name,&buf)==-1)return 0;
  1119.    size=buf.st_size,
  1120. /* get mem for the file */
  1121.    store=allocm(size+2);
  1122. /* read file */
  1123.    if((f=open(name,O_RDONLY))==-1){
  1124.       free(store);
  1125.       return 0;
  1126.    }
  1127.    if(read(f,store,size)!=size){
  1128.       free(store);
  1129.       return 0;
  1130.    }
  1131.    close(f);
  1132.    if(store[size-1]!='\n')store[size++]='\n'; /* terminate last line */
  1133.    store[size]=0;
  1134.    *sourcelen=size;  /* Ahem! */
  1135.    return store;
  1136. }
  1137.  
  1138. /* The following function preprocesses a block of source passed to it.
  1139.    Space for the preprocessed program and the label tabel is allocated
  1140.    and assigned to global variables.  Also, the source is broken into
  1141.    lines and a source line table is allocated.  The 0th line of source
  1142.    is usually its file name.  However this will be inserted by the caller. */
  1143. void tokenise(input,ilen,interpret,line1)
  1144. char *input;         /* the source code */
  1145. int ilen;            /* length of the source code */
  1146. int interpret;       /* if nonzero, ignore labels and do not make a source
  1147.                         line table */
  1148. int line1;           /* if nonzero, the first line is a comment */
  1149. {
  1150.    static char msg[20];/* For reporting invalid chars */
  1151.    int type;         /* Type of a character */
  1152.    int comment=0;    /* Comment nesting level */
  1153.    int commentstart; /* Start stmt number of a comment */
  1154.    int comma=0;      /* Continuation character is in force */
  1155.    int start=1;      /* the start of a statement */
  1156.    char first=0;     /* the first word in this statement */
  1157.    char last=0;      /* the most recent word in this statement */
  1158.    char token=0;     /* candidate token number */
  1159.    int spc=0;        /* a space just occurred */
  1160.    int wordlen=0;    /* length of a stored word */
  1161. #define word varnamebuf /* "word" seems a better name just now */
  1162.    int spcbefore=0;  /* Put a space before the word */
  1163.    int gobble=0;     /* whether a character gobbles spaces */
  1164.    int sourcelen=100;/* lines allocated in source line table */
  1165.    int proglen=100;  /* statements allocated in program line table */
  1166.    int plen=ilen;    /* length allocated for program */
  1167.    char*srcptr=input;/* pointer into the source */
  1168.    char *prgptr;     /* pointer into the program */
  1169.    char *prevptr;    /* source address for the stored word */
  1170.    int lablen;       /* Length allocated to labels */
  1171.    int elabptr;      /* Length of labels so far */
  1172.    char c;
  1173.    char *ptr;
  1174.    int i;
  1175.    int ch;
  1176.  
  1177.    if(!interpret)source=(char**)allocm(sourcelen*sizeof(char*));
  1178.    prog=(program*)allocm(proglen*sizeof(program));
  1179.    prgptr=prog[0].line=allocm(plen);/* plen=ilen is a guaranteed upper bound */
  1180.    prog[0].source=input;
  1181.    prog[0].num=!interpret;
  1182.    if(!interpret)
  1183.       source[0]=cnull,
  1184.       labelptr=allocm(lablen=200),
  1185.       elabptr=0;
  1186.    stmts=0;
  1187.    if(!interpret)lines=0;
  1188.    if(!interpret && (line1 || ilen>2&&srcptr[0]=='#'&&srcptr[1]=='!')){
  1189.       source[++lines]=srcptr;
  1190.       while(ilen--&&srcptr++[0]!='\n');
  1191.       if(ilen<0)ilen++;
  1192.       else srcptr[-1]=0;
  1193.    }
  1194.    prog[0].sourcend=srcptr;
  1195.    if(ilen){
  1196.       if(!interpret)source[++lines]=srcptr;
  1197.       prog[++stmts].line=prgptr,
  1198.       prog[stmts].num=(interpret?0:lines),
  1199.       prog[stmts].source=srcptr,
  1200.       prog[stmts].sourcend=0,
  1201.       prog[stmts].related=0;
  1202.    }
  1203.    ppc=0;                 /* this must be a signal that no ppc is available */
  1204.    while(ilen-- || !interpret&&srcptr>source[lines] || wordlen || !start){
  1205.       if(ilen<0){         /* we repeat the loop to finish off the source */
  1206.          ilen++;          /* This happens when the last line is unterminated */
  1207.                       /* The last byte of source will be overwritten with
  1208.                       \0.  This only fails if input was an empty string. */
  1209.          c='\n';
  1210.       }
  1211.       else c=srcptr++[0];
  1212.       if(c=='\n'){
  1213.          srcptr[-1]=0;
  1214.          if(!interpret){
  1215.         if(sourcelen==++lines)
  1216.            if(ptr=(char*)realloc((char*)source,(sourcelen+=50)*sizeof(char*)))
  1217.               source=(char**)ptr;
  1218.            else die(Emem);
  1219.         source[lines]=srcptr;
  1220.           if(comma){
  1221.            if(!ilen)die(Ecomma); /* Last line ended with comma */
  1222.            prgptr--,
  1223.            gobble--,     /* restore gobble to previous val */
  1224.            comma=0,
  1225.            c=' ';
  1226.         }
  1227.         else c=';';      /* line ends terminate statements.  Note:
  1228.                             this is ineffective within comments */
  1229.      }
  1230.      else
  1231.         if(!ilen)
  1232.            if(comma)die(Ecomma); /* interpreted line ends with comma */
  1233.            else c=';';           /* terminate the interpreted line */
  1234.         else /* do nothing.  \n will be rejected later. */ ;
  1235.       }
  1236.       if(c=='^')c='\\';   /* Translate "^" into the real "not" character */
  1237.       if(c=='*'&&ilen&&srcptr[0]=='/'){
  1238.          if(--comment<0)die(Ercomm); /* Not an error really... */
  1239.      srcptr++,ilen--;
  1240.      c=' ';           /* Comment equals space.  This should be changed. */
  1241.       }
  1242.       if(c=='/'&&ilen&&srcptr[0]=='*'){
  1243.          if(comment++==0)commentstart=stmts;
  1244.      srcptr++,ilen--;
  1245.       }
  1246.       if(comment)continue;/* all characters within comments are ignored. */
  1247.       if((type=whattype(c))==-2){           /* Invalid character */
  1248.          if(c<127&&c>' ')sprintf(errordata=msg,": \'%c\'",c);
  1249.      else sprintf(errordata=msg,": \'%02x\'x",(int)(unsigned char)c);
  1250.      die(Echar);
  1251.       }
  1252.       if(c==' '||c=='\t'){
  1253.          spc=1;
  1254.      continue;
  1255.       }
  1256.       /* A non-blank source character has been found within a line */
  1257.       /* Time to emit the stored word (if any) */
  1258.       comma=0;
  1259.       if(c==':'&&start&&wordlen){             /* the stored word is a label */
  1260.      if(rexxsymbol(word[0])<1)die(Ename); /* Starts with number or dot */
  1261.      if(word[wordlen-1]=='.')die(Elabeldot); /* Ends with dot */
  1262.          if(!interpret){
  1263.             mtest(labelptr,lablen,elabptr+wordlen+4*four,256+wordlen);
  1264.         *((int *)(labelptr+elabptr))=wordlen,
  1265.         *((int *)(labelptr+elabptr)+1)=stmts,
  1266.         memcpy(labelptr+(elabptr+=2*four),word,wordlen),
  1267.         *(labelptr+elabptr+wordlen)=0,
  1268.         elabptr+=align(wordlen+1);
  1269.      }
  1270.          wordlen=spcbefore=spc=0;
  1271.      gobble=1;
  1272.      prog[stmts].source=srcptr,           /* the label is not part of the*/
  1273.      prog[stmts].num=(interpret?0:lines); /* source for the next stmt */
  1274.      continue;
  1275.       }
  1276.       /* as it is not a label, the word is uppercased */
  1277.       for(i=wordlen,ptr=word;i--;ptr++)ptr[0]=uc(ptr[0]);
  1278.       if(c=='='&&wordlen&&(start||last==DO)){ /* the stored word is a symbol */
  1279.          if(rexxsymbol(word[0])<1)die(Ename); /* Starts with number or dot */
  1280.          memcpy(prgptr,word,wordlen),
  1281.      prgptr+=wordlen,
  1282.      prgptr++[0]=c,
  1283.      wordlen=spcbefore=spc=0;
  1284.      gobble=1;
  1285.      start=0;
  1286.      last=0;
  1287.      continue;
  1288.       }
  1289.       /* the word may now be a token. */
  1290.       if(wordlen){
  1291.          for(i=0;i<numwords&&strcmp(word,words[i]);i++); 
  1292.      if(i<numwords)token=(i-128);
  1293.      else token=0;
  1294.      if(token<Command&&!start){ /* "Commands" must be at the start, */
  1295.         if(token==NUMERIC&&last==PARSE);  /* except NUMERIC & SELECT */
  1296.         else if(token==SELECT&&first==last&&last==END);
  1297.         else token=0;
  1298.      }
  1299.      else if(token>=Command&&start){ /* at the start must be a "command" */
  1300.         if(token==THEN);             /* except THEN, PULL and ARG */
  1301.         else if(token==ARG||token==PULL)
  1302.            prgptr++[0]=PARSE,
  1303.            prgptr++[0]=UPPER,
  1304.            first=last=PARSE,
  1305.            start=0;
  1306.         else token=0;
  1307.      } /* Now some special case checking... */
  1308.      if(!token); /* no need to check if there is no token */
  1309.      else if(token==VALUE)if(last==ADDRESS||last==FORM||last==TRACE
  1310.                            ||last==PARSE||last==SIGNAL);else token=0;
  1311.          else if(token==UPPER)if(last==PARSE);else token=0;
  1312.      else if(token>=PULL&&token<=LINEIN)if(last==PARSE);else token=0;
  1313.      else if(token==WITH)if(first==VALUE);else token=0;
  1314.      else if(token==ON||token==OFF)if(last==SIGNAL||last==CALL)
  1315.                     first=token;/* allow NAME */ else token=0;
  1316.      else if(token==NAME)if(first==ON)first=token;else token=0;
  1317.      else if(token>=TO&&token<=FOR)if(first==DO);else token=0;
  1318.      else if(token==FOREVER)if(last==DO);else token=0;
  1319.      else if(token==WHILE||token==UNTIL)if(first==DO||first==WHILE)
  1320.                     first=WHILE; /* disable TO, BY, FOR */ else token=0;
  1321.          else if(token==EXPOSE||token==HIDE)if(last==PROCEDURE);else token=0;
  1322.      else if(token>=DIGITS&&token<=FORM)if(first==last&&last==NUMERIC);
  1323.                     else token=0;
  1324.          else if(token==THEN)if(start||first==IF||first==WHEN);else token=0;
  1325.      if(start)first=token;       /* Save first token in each line */
  1326.      if(token!=UPPER)last=token; /* Save the previous token */
  1327.      if(token==VALUE&&first==PARSE)first=token; /* allow WITH */
  1328.      if(token==WITH)first=token;                /* disallow WITH */
  1329.      if(token)wordlen=0;
  1330.       }
  1331.       else token=0;
  1332.       if(wordlen){   /* If there is still a word, it is a symbol */
  1333.          if(spcbefore)prgptr++[0]=' ';
  1334.      memcpy(prgptr,word,wordlen),
  1335.      prgptr+=wordlen,
  1336.      wordlen=0,
  1337.      start=0,
  1338.      gobble=0;
  1339.       }
  1340.       /* Check for space in case we add a new statement or two */
  1341.       if(token==THEN || token==ELSE || token==OTHERWISE || c== ';')
  1342.          if(stmts+3>=proglen)
  1343.            if(ptr=(char*)realloc((char*)prog,(proglen+=50)*sizeof(program)))
  1344.               prog=(program*)ptr;
  1345.            else die(Emem);
  1346.       if(token==THEN || token==ELSE || token==OTHERWISE){
  1347.          /* these tokens start new statements */
  1348.      if(!start){
  1349.         prgptr++[0]=0;
  1350.         prog[stmts].sourcend=prevptr,
  1351.         prog[++stmts].line=prgptr,
  1352.         prog[stmts].source=prevptr,
  1353.         prog[stmts].num=(interpret?0:lines),
  1354.         prog[stmts].related=0;
  1355.      }
  1356.      prgptr++[0]=token,
  1357.      prgptr++[0]=0;
  1358.      prog[stmts].sourcend=srcptr-1;
  1359.          prog[++stmts].line=prgptr,
  1360.      prog[stmts].num=(interpret?0:lines),
  1361.      prog[stmts].source=srcptr-1,
  1362.      prog[stmts].sourcend=0,
  1363.      prog[stmts].related=0;
  1364.      token=0;
  1365.      start=gobble=1;
  1366.      first=last=0;
  1367.       }
  1368.       else if(token){
  1369.      prgptr++[0]=token;
  1370.      gobble=1;
  1371.      start=0;
  1372.       }
  1373.       if(c==';'){
  1374.          if(start){
  1375.         prog[stmts].source=srcptr,        /* delete the source of the */
  1376.         prog[stmts].num=(interpret?0:lines);   /* null statement, but */
  1377.         continue;                         /* don't make an extra line */
  1378.      }
  1379.      prgptr++[0]=0;
  1380.      prog[stmts].sourcend=srcptr-1,
  1381.      prog[++stmts].line=prgptr,
  1382.      prog[stmts].source=srcptr,
  1383.      prog[stmts].sourcend=0,
  1384.      prog[stmts].num=(interpret?0:lines),
  1385.      prog[stmts].related=0;
  1386.      start=gobble=1;
  1387.      first=last=0;
  1388.      continue;
  1389.       }
  1390.       if(c==','){
  1391.          comma=1,
  1392.      gobble++,        /* this saves the previous value of gobble */
  1393.      spc=0,           /* and also makes gobble true */
  1394.      prgptr++[0]=c;
  1395.      continue;
  1396.       }
  1397.       /* Proceed to insert some non-blank characters.  Gobble any previous
  1398.          spaces if necessary. */
  1399.       if(gobble)gobble=spc=0;
  1400.       if(type<=0 && c!='\'' && c!='\"'){ /* non-alpha and non-quote char */
  1401.          if(c!='(')spc=0;                /* all except "(" gobble on left */
  1402.      if(c!=')')gobble=1;             /* all except ")" gobble on right */
  1403.       }
  1404.       if(c=='\"'||c=='\''){
  1405.          if(spc)prgptr++[0]=' ',spc=0;
  1406.          prgptr++[0]=c;
  1407.          while(ilen--&&srcptr[0]!=c&&srcptr[0]!='\n')prgptr++[0]=srcptr++[0];
  1408.      if(srcptr++[0]!=c)die(Equote);
  1409.       }
  1410.       if(!type){                         /* Can't be a token. Just insert it */
  1411.          if(spc)prgptr++[0]=' ',spc=0;
  1412.      prgptr++[0]=c;
  1413.      start=0;
  1414.      continue;
  1415.       }
  1416.       if(type<0){                        /* might be a multi-char operator */
  1417.          ptr=srcptr;
  1418.      i=ilen;
  1419.      wordlen=0;
  1420.      ch=c;
  1421.      while(wordlen<3){
  1422.         while(i&&(ptr[0]==' '||ptr[0]=='\t'))i--,ptr++;
  1423.         if(whattype(ptr[0])!=-1)break;
  1424.         ch=(ch<<8)+ptr[0];
  1425.         ptr++,i--,wordlen++;
  1426.      }
  1427.      token=0;
  1428.      while(!token&&wordlen)
  1429.         switch(ch){
  1430.            case Cconcat: token=CONCAT; break; /* || */
  1431.            case Cxor:    token=LXOR;   break; /* && */
  1432.            case Cequ:    token=EQU;    break; /* == */
  1433.            case Cleq1:                        /* <= */
  1434.            case Cleq2:   token=LEQ;    break; /* \> */
  1435.            case Cgeq1:                        /* >= */
  1436.            case Cgeq2:   token=GEQ;    break; /* \> */
  1437.            case Cneq1:                        /* \= */
  1438.            case Cneq2:                        /* <> */
  1439.            case Cneq3:   token=NEQ;    break; /* >< */
  1440.            case Cnneq:   token=NNEQ;   break; /* \== */
  1441.            case Cmod:    token=MOD;    break; /* // */
  1442.            case Cless:   token=LESS;   break; /* << */
  1443.            case Cgrtr:   token=GRTR;   break; /* >> */
  1444.            case Clleq1:                       /* <<= */
  1445.            case Clleq2:  token=LLEQ;   break; /* \>> */
  1446.            case Cggeq1:                       /* >>= */
  1447.            case Cggeq2:  token=GGEQ;   break; /* \<< */
  1448.            case Cpower:  token=POWER;  break; /* ** */
  1449.            default: ch>>=8,wordlen--;
  1450.         }
  1451.          if(token)ch=token;
  1452.      prgptr++[0]=ch;
  1453.      while(wordlen){
  1454.         while(ptr[0]==' '||ptr[0]=='\t')ilen--,srcptr++;
  1455.         ilen--,srcptr++,wordlen--;
  1456.      }
  1457.      gobble=1;
  1458.      start=0;
  1459.      continue;
  1460.       }
  1461.       /* We have an alphanumeric character.  Store a word. */
  1462.       prevptr=srcptr-1;
  1463.       spcbefore=spc;
  1464.       spc=gobble=0;
  1465.       ptr=srcptr-1;
  1466.       while(ilen--&&rexxsymboldot(srcptr++[0]));
  1467.       if(++ilen>0)srcptr--;
  1468.       wordlen=srcptr-ptr;
  1469.       mtest(word,varnamelen,wordlen+1,wordlen+1-varnamelen);
  1470.       memcpy(word,ptr,wordlen),
  1471.       word[wordlen]=0;
  1472.    }
  1473.    /* All characters considered; ilen was zero and the source was terminated */
  1474.    prgptr++[0]=0;
  1475.    prog[stmts].sourcend=srcptr-1;
  1476.    if(!interpret)lines--;  /* Discount the new line started at the last '\n' */
  1477.                            /* It will remain in the line table, however. */
  1478.    /* Now shrink all areas to their correct sizes */
  1479.    if(ptr=realloc((char*)prog,(1+stmts)*sizeof(program)))
  1480.       prog=(program*)ptr;
  1481.    if(!interpret && (ptr=realloc((char*)source,(2+lines)*sizeof(char*))))
  1482.       source=(char**)ptr;
  1483.    if(ptr=realloc(prog[0].line,prgptr-prog[0].line))
  1484.       if(ptr!=prog[0].line)
  1485.          /* Oops, the program moved! */
  1486.          for(i=stmts;i--;prog[i].line+=ptr-prog[0].line);
  1487.    if(!interpret){
  1488.       if(ptr=realloc(labelptr,elabptr+four))
  1489.          labelptr=ptr;
  1490.       (*(int *)(labelptr+elabptr))=0;
  1491.    }
  1492.    if(comment)stmts=commentstart,die(Elcomm);
  1493. }
  1494. #undef word
  1495.  
  1496. /* This function prints the source associated with a particular statement.
  1497.    If "after" is non-zero, it prints the source (if any) occurring between
  1498.    this statement and the next.  It prefixes the source with "*-*" unless
  1499.    "error" is non-zero, in which case the prefix is "+++". */
  1500. void printstmt(stmt,after,error)
  1501. int stmt,after,error;
  1502. {
  1503.    int line=prog[stmt].num;      /* source line number */
  1504.    char *start,*end;             /* start and end of the source */
  1505.    char *what=error?"+++":"*-*"; /* The trace prefix */
  1506.    int spc;                      /* How much indentation there is */
  1507.    char *ptr;
  1508.    int i;
  1509.    if(stmt>stmts){               /* This never happens, I hope... */
  1510.       fprintf(traceout,"%5d %s <EOF>\n",lines+1,what);
  1511.       return;
  1512.    }
  1513.    else if(after){
  1514.       for(start=prog[stmt].source;start<prog[stmt].sourcend;start++)
  1515.          if(line&&start+1==source[line+1])
  1516.         ++line;     /* find the line number of the source end */
  1517.       end=prog[stmt+1].source;
  1518.    }
  1519.    else start=prog[stmt].source,end=prog[stmt].sourcend;
  1520.    if(!end){                     /* This never happens, I hope... */
  1521.       fprintf(traceout,"%5d %s <EOL>\n",line,what);
  1522.       return;
  1523.    }
  1524.    while(start<end&&
  1525.         (start[0]==0||start[0]==';'||start[0]==' '|start[0]=='\t')){
  1526.       if(line&&start+1==source[line+1])
  1527.          ++line;
  1528.       start++;                   /* step past uninteresting chars */
  1529.    }
  1530.    while(start<end&&
  1531.         (end[-1]==0||end[-1]==';'||end[-1]==' '|end[-1]=='\t'))
  1532.       end--;                     /* delete uninteresting trailing chars */
  1533.    if(start>=end)return;         /* Nothing to print. */
  1534.    if(line)
  1535.       for(spc=0,ptr=source[line];ptr<start;ptr++)
  1536.          if(ptr[0]=='\t')spc=8+(spc&~7);/* This calculates the column within */
  1537.          else spc++;             /* the line in which the statement starts   */
  1538.    else spc=0;
  1539.    do{
  1540.       if(line)fprintf(traceout,"%5d %s ",line,what);
  1541.       else    fprintf(traceout,"      %s ",what);
  1542.       for(i=0;i<traceindent*pstacklev;i++)putc(' ',traceout);    /* indent */
  1543.       for(i=0;i<spc&&start<end&&(start[0]==' '||start[0]=='\t');start++)
  1544.          if(start[0]=='\t')i=8+(i&~7);            /* Remove leading spaces */
  1545.      else i++;
  1546.       while(i>spc)putc(' ',traceout),i--;/* Print part of a tab if necessary */
  1547.       for(;start<end&&(!line||start<source[line+1]-1);start++)
  1548.          if((i=start[0]&127)<' '||i==127)putc('?',traceout);
  1549.          else putc(i,traceout);                         /* Print statement */
  1550.       if(start<end&&line<lines)start=source[++line];    /* Go to next line */
  1551.       putc('\n',traceout);
  1552.    } while(start<end&&line<=lines);
  1553. }
  1554. #if 0
  1555. void expand(c)   /* this is an old test routine. */
  1556. char c;
  1557. {
  1558.    static char *symwords[]={"||","&&","==","<=",">=","<>","\\==","//","<<",">>","<<=",">>=","**"};
  1559.    static char invvideo[]={27,'[','1','m',0};
  1560.    static char truevideo[]={27,'[','m',0};
  1561.    if(c==-1){printf("%s;%s",invvideo,truevideo);return;}
  1562.    printf("%s ",invvideo);
  1563.    if(c>SYMBOL)printf("%s",symwords[c-(SYMBOL+1)]);
  1564.    if(c<numwords-128)printf(words[c+128]);
  1565.    printf(" %s",truevideo);
  1566. }
  1567.  
  1568. void display(line,ptr) /* so is this */
  1569. int line,ptr;
  1570. {
  1571.    char *s=((*prog)[line]);
  1572.    char c;
  1573.    int i=0;
  1574.    printf("      +++ %d +++ ",ppc);
  1575.    if(s==cnull)puts("(null)");
  1576.    while(c=s[i++]){
  1577.       if(c<0)expand(c);
  1578.       else putchar(c);
  1579.       if(i==ptr)printf("[*]");
  1580.    }
  1581.    putchar('\n');
  1582. }
  1583. #endif /* end of the old tokenisation routines which are commented out */
  1584.  
  1585. int which(gn,opt,fn)/* finds a file given name `gn'; puts path name in `fn'.
  1586.                      opt=0 indicates that the default extension should be
  1587.                    appended, unless it is already at the end of gn 
  1588.                      opt=1 indicates that it is not to be appended.
  1589.                      opt=2 means search for ".rxfn" file first. */
  1590. char *fn,*gn;
  1591. int opt;            /* returns 0 if not found, 1 if rexx found, */
  1592. {                   /*         2 if executable found            */
  1593.    char *getwd();
  1594.    char tmp[MAXPATHLEN];
  1595.    char *getenv();
  1596.    char *path=getenv("PATH");
  1597.    char *pathptr;
  1598.    char *ep;
  1599.    char *ext=opt==2?".rxfn":extension; /* First extension to try */
  1600.    int len=opt==2?5:extlen;            /* Length of extension */
  1601.    int glen=strlen(gn);
  1602.    int times=1+(opt!=1&&strcmp(extension,filetype))+(opt==2);/* how many tries*/
  1603.    int dot=1;                          /* whether current dir wasn't in path */
  1604.    while(times--){
  1605.       pathptr=path;
  1606.       strcpy(tmp,gn);
  1607.       if(opt!=1&&(glen<len||strcmp(gn+glen-len,ext)))strcat(tmp,ext);
  1608.       if(!strchr(tmp,'/')&&path){
  1609.          /* search path for file */
  1610.          while(pathptr[0]){
  1611.             if((ep=strchr(pathptr,':'))==cnull)/* find end of directory name */
  1612.            ep=strchr(pathptr,0);
  1613.             else ep[0]=0,ep++;                 /* Temporarily erase the ":" */
  1614.         if(pathptr[0]=='.'&&!pathptr[1]){  /* Find real name of "." */
  1615.            dot=0;
  1616.                if(getwd(fn))strcat(fn,"/");
  1617.            else fn[0]=0;
  1618.         }
  1619.             else strcpy(fn,pathptr),
  1620.                  strcat(fn,"/");
  1621.             strcat(fn,tmp);
  1622.             if(ep[0])ep[-1]=':'; /* put back the colon we erased earlier */
  1623.             if(!access(fn,0))return 1+(opt==2); /* Found it. */
  1624.             pathptr=ep;
  1625.          }
  1626.       }
  1627.       /* finally, check current directory */
  1628.       if(dot){
  1629.          fn[0]=0;
  1630.          if(tmp[0]!='/')
  1631.             if(getwd(fn))strcat(fn,"/");
  1632.             else fn[0]=0;
  1633.          strcat(fn,tmp);
  1634.          if(!access(fn,0))return 1+(opt==2);
  1635.       }
  1636.       if(opt==2) /* Find the next extension to try (if any) */
  1637.          opt=0,
  1638.      ext=extension,
  1639.      len=extlen;
  1640.       else ext=filetype,len=sizeof filetype-1;
  1641.    }
  1642.    /* The file was not found. Make a representation of the searched-for
  1643.       name and return 0 */
  1644.    strcpy(fn,gn);
  1645.    if(opt!=1&&(glen<extlen||strcmp(gn+glen-extlen,extension)))
  1646.       strcat(fn,extension);
  1647.    return 0;
  1648. }
  1649.  
  1650. /* Hash table routines */
  1651. /* These routines maintain several tables (not actually hash tables, but
  1652.    never mind) in the style of the above variable handling routines, except
  1653.    that each table is single-level.
  1654.    Each table entry contains a hashent structure containing the following
  1655.    fields: next (length), grtr, less (tree pointer fields), value (the void*
  1656.    value associated with the name), and name. The name is a NUL-
  1657.    terminated sequence of characters followed by pad bytes to make up a
  1658.    multiple of 4 bytes.
  1659.    The hash tables maintained are:
  1660.    0. environment variable names => address of storage for their values
  1661.    1. file names => address of a structure containing their details
  1662.    2. function names => address of structure containing their details
  1663.  
  1664.    Each hash table is characterised by three values: hashptr[x] is the
  1665.    address of hash table x, hashlen[x] is the amount of storage allocated,
  1666.    and ehashptr[x] is the actual length of the table.
  1667. */
  1668.  
  1669. char *hashsearch(hash,name,exist)
  1670. int hash;
  1671. char *name;
  1672. int *exist;
  1673. /* search for name `name' of length `len' in hash table `hash'.
  1674.    The answer is the address of the entry which matches, with `exist'
  1675.    non-zero, or, if the name does not exist, exist=0 and the answer
  1676.    is the address of the slot where the new branch of the tree is to
  1677.    be added. If there are no names in the table, 0 is returned. */
  1678. {
  1679.    char *data=hashptr[hash];
  1680.    char *ans=data;
  1681.    int *slot;
  1682.    int c;
  1683.    *exist=0;
  1684.    if(!ehashptr[hash])return cnull;
  1685.    while((c=strcmp(name,ans+sizeof(hashent)))
  1686.      &&  (*(slot= &(((hashent *)ans)->less)+(c>0)))>=0)
  1687.    ans=data+*slot;
  1688.    if(!c)return *exist=1,ans;
  1689.    return(char*)slot;
  1690. }
  1691.  
  1692. void *hashget(hash,name,exist) /* like hashsearch, but the value is returned */
  1693. int hash;                      /* (if any) */
  1694. char *name;
  1695. int *exist;
  1696. {  
  1697.    char *ptr=hashsearch(hash,name,exist);
  1698.    if(*exist)return((hashent *)ptr)->value;
  1699.    else return 0;
  1700. }
  1701.  
  1702. void **hashfind(hash,name,exist)
  1703. int hash;
  1704. char *name;
  1705. int *exist;
  1706. {  /* like hashsearch, but the address of the value is returned. If no
  1707.       value is present, one is created. */
  1708.    char *ptr=hashsearch(hash,name,exist);
  1709.    int len;
  1710.    if(*exist)return &(((hashent *)ptr)->value);
  1711.    if(ptr)*(int *)ptr=ehashptr[hash];
  1712.    len=align(strlen(name)+1)+sizeof(hashent);
  1713.    mtest(hashptr[hash],hashlen[hash],ehashptr[hash]+len,len+256);
  1714.    ptr=hashptr[hash]+ehashptr[hash],
  1715.    ehashptr[hash]+=len,
  1716.    ((hashent *)ptr)->next=len,
  1717.    ((hashent *)ptr)->less=-1,
  1718.    ((hashent *)ptr)->grtr=-1,
  1719.    strcpy(ptr+sizeof(hashent),name);
  1720.    return &(((hashent *)ptr)->value);
  1721. }
  1722.  
  1723. struct fileinfo *fileinit(name,filename,fp) 
  1724. char *name,*filename;          /* associate "name" with the file "filename" */
  1725. FILE *fp;                      /* which has just been opened on fp          */
  1726. {                              /* return the fileinfo structure created     */
  1727.    int exist;
  1728.    struct stat buf;            /* For finding the file's details */
  1729.    void **entry=hashfind(1,name,&exist);
  1730.    unsigned len=align(filename?strlen(filename)+1:1);
  1731.    struct fileinfo *info=
  1732.       (struct fileinfo *)allocm(sizeof(struct fileinfo)+len);
  1733.    if(exist&&*entry)           /* What if the name is already used? */
  1734.       fclose(((struct fileinfo *)(*entry))->fp),
  1735.       free((char*)(*entry));
  1736.    *entry=(void *)info;
  1737.    if(filename)strcpy((char*)(info+1),filename);
  1738.    else *(char*)(info+1)=0;
  1739.    if(fp && fstat(fileno(fp),&buf)==0)    /* Make the file persistent if and */
  1740.       info->persist=S_ISREG(buf.st_mode); /* only if it can be determined    */
  1741.    else info->persist=0;                  /* that it is a regular file       */
  1742.    info->fp=fp,                /* fill in the structure with suitable */
  1743.    info->wr=0,                 /* defaults */
  1744.    info->lastwr=1,             /* lastwr=1 so that the first read does seek */
  1745.    info->rdpos=0,              /* usually read from beginning of file */
  1746.    info->rdline=1,
  1747.    info->rdchars=0,
  1748.    info->wrpos=fp?ftell(fp):0, /* Usually write to end of file */
  1749.    info->wrline=!info->wrpos,
  1750.    info->wrchars=0,
  1751.    info->errno=0;
  1752.    if(info->wrpos<0)info->wrpos=0; /* In case ftell failed */
  1753.    return info;
  1754. }
  1755.  
  1756. void funcinit(name,handle,address) /* Associate "name" with a function */
  1757. char *name;      /* The REXX name of the function */
  1758. void *handle;    /* The handle from dlopen(), if this is the "main" function */
  1759. int (*address)();/* The address of the function's implementation */
  1760. {
  1761.    funcinfo *info;
  1762.    int exist;
  1763.    void **slot=hashfind(2,name,&exist);
  1764.    if(!(exist&&*slot)) /* if it exists, a dl handle might be lost. */
  1765.       info=(funcinfo *)allocm(sizeof(funcinfo)),
  1766.       *slot=(void *)info;
  1767.    info->dlhandle=handle;
  1768.    info->dlfunc=address;
  1769. }
  1770.  
  1771. int fileclose(name)  /* close and free the file associated with "name" */
  1772. char *name;          /* return the code from close */
  1773. {
  1774.    int exist;
  1775.    int ans=0;
  1776.    char *ptr=hashsearch(1,name,&exist);
  1777.    struct fileinfo *info;
  1778.    if(!exist)return 0;
  1779.    info=(struct fileinfo *)(((hashent *)ptr)->value);
  1780.    if(info){
  1781.       if(info->fp)ans=fclose(info->fp),
  1782.       free((char*)info);
  1783.    }
  1784.    ((hashent *)ptr)->value=0;
  1785.    return ans;
  1786. }
  1787.  
  1788. void hashfree() /* free all memory used by hash tables */
  1789. {
  1790.    int hash;
  1791.    int len;
  1792.    hashent *ptr;
  1793.    for(hash=0;hash<3;hash++){
  1794.       if(!(ptr=(hashent *)hashptr[hash]))continue;
  1795.       for(len=ehashptr[hash];len;
  1796.           len-=ptr->next,ptr=(hashent*)((char *)ptr+ptr->next))
  1797.          switch(hash){
  1798.         case 2: if(((funcinfo *)(ptr->value))->dlhandle)
  1799.                 dlclose(((funcinfo *)(ptr->value))->dlhandle);
  1800.             free((char *)(ptr->value));
  1801.             break;
  1802.         case 1: if(!(ptr->value))break;
  1803.                 if(((struct fileinfo *)(ptr->value))->fp)
  1804.                    fclose(((struct fileinfo *)(ptr->value))->fp);
  1805.         default: free((char *)(ptr->value));
  1806.      }
  1807.       free(hashptr[hash]);
  1808.    }
  1809. }
  1810.  
  1811. #ifdef NO_LDL /* Define dummy versions of the dynamic load functions */
  1812. void *dlopen(path, mode)
  1813. char *path; int mode;
  1814. {die(Eexist);/*NOTREACHED*/}
  1815.  
  1816. void *dlsym(handle,sym)
  1817. void *handle; char *sym;
  1818. {die(Eexist);/*NOTREACHED*/}
  1819.  
  1820. char *dlerror()
  1821. {die(Eexist);/*NOTREACHED*/}
  1822.  
  1823. int dlclose(handle)
  1824. void *handle;
  1825. {die(Eexist);/*NOTREACHED*/}
  1826.             
  1827. #endif
  1828.